home *** CD-ROM | disk | FTP | other *** search
/ The CICA Windows Explosion! / The CICA Windows Explosion! - Disc 2.iso / programr / wtj007.zip / SWAN.ZIP / COMMON.PAS
Pascal/Delphi Source File  |  1992-07-24  |  10KB  |  342 lines
  1. (* ----------------------------------------------------------- *(
  2. **  COMMON.PAS -- Windows 3.1 common dialogs demonstration     **
  3. ** ----------------------------------------------------------- **
  4. **  This program demonstrates how to use the nine common       **
  5. **  dialogs in Windows 3.1 with Turbo Pascal for Windows. The  **
  6. **  program requires TPW 1.0 (patched for Windows 3.1) or you  **
  7. **  can use TPW 1.5. The program DOES NOT COMPILE with the     **
  8. **  original unpatched TPW 1.0.                                **
  9. ** ----------------------------------------------------------- **
  10. **       Copyright (c) 1992 by Tom Swan. Use as you wish       **
  11. )* ----------------------------------------------------------- *)
  12.  
  13. program Common;
  14.  
  15. {$R common.res}
  16.  
  17. uses WObjects, WinTypes, WinProcs, Strings, Win31, CommDlg;
  18.  
  19. {$I common.inc}
  20.  
  21. const
  22.  
  23.   em_BadVersion = -100;
  24.  
  25. type
  26.  
  27.   TColorArray = array[0 .. 15] of TColorRef;
  28.  
  29.   TCommApp = object(TApplication)
  30.     procedure Error(ErrorCode: Integer); virtual;
  31.     procedure InitInstance; virtual;
  32.     procedure InitMainWindow; virtual;
  33.   end;
  34.  
  35.   PCommWin = ^TCommWin;
  36.   TCommWin = object(TWindow)
  37.   {- Color dialog data members }
  38.     Color: TColorRef;  { Selected color }
  39.     AColors: TColorArray;  { Custom color array }
  40.   {- Font dialog data member }
  41.     Font: TLogFont;  { Logical font }
  42.   {- File dialog data members }
  43.     Filename: array[0 .. 255] of Char;  { Current file name }    
  44. FilterStr: array[0 .. 80] of Char;  { File filter list }    
  45. FilterIndex: Integer;  { Number of filter for dlg list box }   {-
  46. Find and replace dialog data members }
  47.     HFindDLG: HWND;
  48.     FindStr: array[0 .. 40] of Char;
  49.     ReplaceStr: array[0 .. 40] of Char;
  50.     FR: TFindReplace;
  51.   {- Constructor }
  52.     constructor Init(AParent: PWindowsObject; ATitle: PChar);   {-
  53. Inherited methods }
  54.     function GetClassName: PChar; virtual;
  55.     procedure GetWindowClass(var AWndClass: TWndClass); virtual;  
  56. {- Message-response methods (menu commands) }
  57.     procedure CMFileExit(var Msg: TMessage);
  58.       virtual cm_First + cm_FileExit;
  59.     procedure CMDialogsColor(var Msg: TMessage);
  60.       virtual cm_First + cm_DialogsColor;
  61.     procedure CMDialogsFont(var Msg: TMessage);
  62.       virtual cm_First + cm_DialogsFont;
  63.     procedure CMDialogsOpen(var Msg: TMessage);
  64.       virtual cm_First + cm_DialogsOpen;
  65.     procedure CMDialogsSaveAs(var Msg: TMessage);
  66.       virtual cm_First + cm_DialogsSaveAs;
  67.     procedure CMDialogsPrint(var Msg: TMessage);
  68.       virtual cm_First + cm_DialogsPrint;
  69.     procedure CMDialogsFind(var Msg: TMessage);
  70.       virtual cm_First + cm_DialogsFind;
  71.     procedure CMDialogsReplace(var Msg: TMessage);
  72.       virtual cm_First + cm_DialogsReplace;
  73.     procedure CMHelpAbout(var Msg: TMessage);
  74.       virtual cm_First + cm_HelpAbout;
  75.   end;
  76.  
  77. { TCommApp }
  78.  
  79. {- Respond to startup errors }
  80. procedure TCommApp.Error(ErrorCode: Integer);
  81. begin
  82.   if Status = em_BadVersion then
  83.     MessageBox(0, 'Requires Windows 3.1 or later',
  84.       'Version Error', mb_ApplModal or mb_IconStop or mb_Ok)   else
  85.     TApplication.Error(ErrorCode);
  86. end;
  87.  
  88. {- Detect Windows version number. Halt if < 3.1. }
  89. procedure TCommApp.InitInstance;
  90. var
  91.   Version: LongInt;
  92.   MajorRev, MinorRev: Byte;
  93.   Okay: Boolean;
  94. begin
  95.   Version := GetVersion;
  96.   MajorRev := LOBYTE(LOWORD(Version));
  97.   MinorRev := HIBYTE(LOWORD(Version));
  98.   if (MajorRev < 3) then Okay := false else
  99.   if (MajorRev = 3) then Okay := (MinorRev >= 1) else
  100.   if (MajorRev > 3) then Okay := true;  { I hope! }
  101.   if Okay then
  102.     TApplication.InitInstance
  103.   else
  104.     Status := em_BadVersion;
  105. end;
  106.  
  107. {- Initialize the application's window }
  108. procedure TCommApp.InitMainWindow;
  109. begin
  110.   MainWindow := New(PCommWin, Init(nil, 'Common Dialogs')); end;
  111.  
  112. { TCommWin }
  113.  
  114. {- Initialize the application's window object }
  115. constructor TCommWin.Init(AParent: PWindowsObject; ATitle:PChar);
  116. var
  117.   I: Integer;
  118. begin
  119.   TWindow.Init(AParent, ATitle);
  120.   with Attr do
  121.   begin
  122.     Menu := LoadMenu(HInstance, PChar(id_Menu));
  123.     X := GetSystemMetrics(sm_CXScreen) div 8;
  124.     Y := GetSystemMetrics(sm_CYScreen) div 8;
  125.     H := Y * 6;
  126.     W := X * 6;
  127.   end;
  128. {- Initialize color dialog data members }
  129.   Color := RGB(0, 0, 0);  { Initial color }
  130.   for I := 0 to 15 do     { Set custom colors to white }
  131.     AColors[I] := RGB(255, 255, 255);
  132. {- Initialize logical font data members }
  133.   FillChar(Font, sizeof(Font), #0);
  134. {- Initialize file name and list-box filters (wild cards) }  
  135. Filename[0] := #0;
  136.   if LoadString(HInstance, str_FileFilters, FilterStr,
  137.                 Sizeof(FilterStr)) = 0 then
  138.     FilterStr[0] := #0
  139.   else
  140.     for I := 0 to StrLen(FilterStr) do
  141.       if FilterStr[I] = '|' then
  142.         FilterStr[I] := #0;
  143.   FilterIndex := 1;
  144. {- Initialize find and replace data members }
  145.   HFindDlg := 0;
  146.   FindStr[0] := #0;
  147.   ReplaceStr[0] := #0;
  148. end;
  149.  
  150. {- Return unique name for modified window class }
  151. function TCommWin.GetClassName: PChar;
  152. begin
  153.   GetClassName := 'TCommWin';
  154. end;
  155.  
  156. {- Modify window class to use custom icon }
  157. procedure TCommWin.GetWindowClass(var AWndClass: TWndClass); begin
  158.   TWindow.GetWindowClass(AWndClass);
  159.   AWndClass.HIcon := LoadIcon(HInstance, PChar(id_Icon));
  160. end;
  161. {- Exit program by closing the main window }
  162. procedure TCommWin.CMFileExit(var Msg: TMessage);
  163. begin
  164.   CloseWindow;
  165. end;
  166.  
  167. {- DIALOG #1: Common color dialog }
  168. procedure TCommWin.CMDialogsColor(var Msg: TMessage);
  169. var
  170.   CC: TChooseColor;
  171.   TempColors: TColorArray;
  172. begin
  173.   FillChar(CC, Sizeof(CC), #0);
  174.   TempColors := AColors;  { Copy current color array }
  175.   with CC do
  176.   begin
  177.     lStructSize := Sizeof(TChooseColor);
  178.     hwndOwner := HWindow;
  179.     Flags := cc_RGBInit or cc_FullOpen;
  180.     rgbResult := Color;
  181.     lpCustColors := @TempColors;
  182.   end;
  183.   if (ChooseColor(CC)) then with CC do
  184.   begin
  185.     Color := rgbResult;  { Use this color to draw }
  186.     AColors := TempColors;  { Save custom color array }
  187.   end;
  188. end;
  189.  
  190. {- DIALOG #2: Common font-selection dialog }
  191. procedure TCommWin.CMDialogsFont(var Msg: TMessage);
  192. var
  193.   CF: TChooseFont;
  194.   TempFont: TLogFont;
  195. begin
  196.   FillChar(CF, Sizeof(CF), #0);
  197.   TempFont := Font;  { Copy current font }
  198.   with CF do
  199.   begin
  200.     lStructSize := SizeOf(TChooseFont);
  201.     HWndOwner := HWindow;
  202.     Flags := cf_InitToLogFontStruct or cf_Both or cf_Effects;    
  203. lpLogFont := @TempFont;
  204.     rgbColors := Color;  { Selected by Color dialog }
  205.   end;
  206.   if ChooseFont(CF) then with CF do
  207.   begin
  208.     Font := lpLogFont^;  { Use this font for text }
  209.   end;
  210. end;
  211.  
  212. {- DIALOG #3: Common file-open dialog }
  213. procedure TCommWin.CMDialogsOpen(var Msg: TMessage);
  214. var
  215.   FN: TOpenFilename;
  216.   Tempname: array[0 .. 255] of Char;
  217. begin
  218.   FillChar(FN, Sizeof(FN), #0);
  219.   StrCopy(Tempname, Filename);  { Copy current file name }
  220.   with FN do
  221.   begin
  222.     lStructSize := SizeOf(TOpenFilename);
  223.     hWndOwner := HWindow;
  224.     Flags := ofn_PathMustExist or ofn_FileMustExist;
  225.     lpstrFile := Tempname;  { Address current file name }
  226.     nMaxFile := Sizeof(Filename);
  227.     lpstrFilter := FilterStr;  { Address file filters }
  228.     nFilterIndex := FilterIndex;  { Filter for list box }
  229.   end;
  230.   if GetOpenFileName(FN) then with FN do
  231.   begin
  232.     StrCopy(Filename, lpstrFile);  { Save selected file name }    
  233. FilterIndex := nFilterIndex;  { Save selected filter # }   end;
  234. end;
  235.  
  236. {- DIALOG #4: Common file-save-as dialog }
  237. procedure TCommWin.CMDialogsSaveAs(var Msg: TMessage);
  238. var
  239.   FN: TOpenFilename;
  240.   Tempname: array[0 .. 255] of Char;
  241. begin
  242.   FillChar(FN, Sizeof(FN), #0);
  243.   StrCopy(Tempname, Filename);  { Copy current file name }
  244.   with FN do
  245.   begin
  246.     lStructSize := SizeOf(TOpenFilename);
  247.     hWndOwner := HWindow;
  248.     Flags := ofn_OverwritePrompt;
  249.     lpstrFile := Tempname;  { Address current file name }
  250.     nMaxFile := Sizeof(Filename);
  251.     lpstrFilter := FilterStr;  { Address file filters }
  252.     nFilterIndex := FilterIndex;  { Filter for list box }
  253.   end;
  254.   if GetSaveFileName(FN) then with FN do
  255.   begin
  256.     StrCopy(Filename, lpstrFile);  { Save selected file name }    
  257. FilterIndex := nFilterIndex;  { Save selected filter # }   end;
  258. end;
  259.  
  260. {- DIALOGS #5-7: Common printer, setup, and options dialogs }
  261. procedure TCommWin.CMDialogsPrint(var Msg: TMessage);
  262. var
  263.   PD: TPrintDlg;
  264. begin
  265.   FillChar(PD, Sizeof(PD), #0);
  266.   with PD do
  267.   begin
  268.     lStructSize := Sizeof(TPrintDlg);
  269.     hWndOwner := HWindow;
  270.     Flags := pd_ReturnDC;  { pd_PrintSetup for setup dlg }
  271.   end;
  272.   if PrintDlg(PD) then
  273.   begin
  274.   {- ... Print using PD.hDC device context. }
  275.     DeleteDC(PD.hDC);
  276.     if PD.hDevMode <> 0 then
  277.       GlobalFree(PD.hDevMode);
  278.     if PD.hDevNames <> 0 then
  279.       GlobalFree(PD.hDevNames);
  280.   end;
  281. end;
  282.  
  283. {- DIALOG #8: Common find-text dialog }
  284. procedure TCommWin.CMDialogsFind(var Msg: TMessage);
  285. begin
  286.   if HFindDLG <> 0 then
  287.   begin
  288.     SendMessage(HFindDLG, wm_Close, 0, 0);
  289.     HFindDLG := 0;
  290.   end;
  291.   FillChar(FR, Sizeof(FR), #0);
  292.   with FR do
  293.   begin
  294.     lStructSize := Sizeof(TFindReplace);
  295.     hwndOwner := HWindow;
  296.     lpstrFindWhat := FindStr;
  297.     wFindWhatLen := Sizeof(FindStr);
  298.   end;
  299.   HFindDLG := FindText(FR)
  300. end;
  301.  
  302. {- DIALOG #9: Common replace-text dialog }
  303. procedure TCommWin.CMDialogsReplace(var Msg: TMessage);
  304. begin
  305.   if HFindDLG <> 0 then
  306.   begin
  307.     SendMessage(HFindDLG, wm_Close, 0, 0);
  308.     HFindDLG := 0;
  309.   end;
  310.   FillChar(FR, Sizeof(FR), #0);
  311.   with FR do
  312.   begin
  313.     lStructSize := Sizeof(FR);
  314.     hwndOwner := HWindow;
  315.     lpstrFindWhat := FindStr;
  316.     wFindWhatLen := Sizeof(FindStr);
  317.     lpstrReplaceWith := ReplaceStr;
  318.     wReplaceWithLen := Sizeof(ReplaceStr);
  319.   end;
  320.   HFindDLG := ReplaceText(FR);
  321. end;
  322.  
  323. {- Display this program's about-box dialog }
  324. procedure TCommWin.CMHelpAbout(var Msg: TMessage);
  325. var
  326.   Dialog: TDialog;
  327. begin
  328.   Dialog.Init(@Self, PChar(id_About));
  329.   Dialog.Execute;
  330.   Dialog.Done;
  331. end;
  332.  
  333. var
  334.   CommApp: TCommApp;
  335. begin
  336.   CommApp.Init('Common');
  337.   CommApp.Run;
  338.   CommApp.Done
  339. end.
  340.  
  341.  
  342.